Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue33/intrposr/EnhCtrls.pas

Pascal/Delphi Source File | 1998-03-04 | 14.2 KB | 546 lines

unit EnhCtrls;
// set of Interposer Components enhancing some of the
// standard Delphi VCL components with often requested additions
//
//
// ⌐Stephen Posey -- [e-mail]
// Written for The Delphi Magazine
//
//////////////////////////////////////////////////////////////////
// Usage: simply add this Unit to the Form's uses clause AFTER
// the unit(s) that declare the original components; then
// just use the provided new methods and properties in your code
// as if they were part of the original class!
//
//////////////////////////////////////////////////////////////////
// References:
// 1) Rubenking, N. (1996).
//    Delphi Programming Problem Solver.
//    Foster City, California, USA: IDG Books.
//    ISBN: 1-56884-795-5
//
// 2) Miano, J.; Cabanski, T.; & Howe, H. (1997).
//    The Waite Group's Borland C++ Builder How-To.
//    Corte Madera, California, USA: Waite Group Press.
//    ISBN: 1-57169-109-X.
//
// 3) Frerking, G.; Wallace, N.; & Niddery, W. (1995).
//    The Waite Group's Borland Delphi How-To.
//    Corte Madera, California, USA: Waite Group Press.
//    ISBN: 1-57169-019-0.
//
// Interposed TPanel:
// * The code for exposing the Canvas property is adapted
//   from widely available for creating a new TPanel descendant
// * The code for adding the "Hi There" method was my invention
//
// Interposed TBitBtn:
// * The code for the font color change when the mouse is over.
//   the button I've had since D1 days, don't recall where I got it.
// * The sound code I came up with for this project.
//
// Interposed TListBox:
// * Both the code for adding the Horizontal scrollbar is adapted
//   from code in reference 1)
// * The sound code I came up with for this project.
//
// Interposed TEdit:
// * The code for Left and center justification is adapted from code
//   in both reference 1) and 2); plus some pretty deep VCL exploration
//   by your author (esp. the call to RecreateWnd
// * The code for character filtering is adapted from code in
//   reference 3)
//
// Interposed TMemo:
// *  Both the code for caret position and for
//    single step Undo is adapted from code in
//    reference 1)

(*****) interface (****************************************)
uses
  Windows, Messages, SysUtils, Classes, Controls,
  Graphics, StdCtrls, ExtCtrls, Buttons ;

type

  TPanel = class(ExtCtrls.TPanel)
  // Interposed TPanel:
  // Exposes the inherited Canvas property
  // Shows example of ADDING an entirely NEW method to a component
  public
    procedure HiThere ;
  published
    property Canvas ;
  end ;

  TBitBtn = class( Buttons.TBitBtn )
  // Interposed TBitBtn:
  // Adds optional font color change when the mouse is over the button
  // Adds optional sound when button pressed
  private
    FEnterChange, FPlaySound : boolean ;
    FNormalColor, FChangeColor : TColor ;
    FSound : integer ;
  protected
    // overridden methods
    constructor Create( AOwner: TComponent ) ; override ;
    procedure Click ; override ;

    // Message Hanlders
    procedure cmMouseEnter( var Msg : TMessage ) ;
      message CM_MOUSEENTER ;
    procedure cmMouseLeave( var Msg : TMessage ) ;
      message CM_MOUSELEAVE ;
  public
  published
    // button caption color change when mouse over button?
    property EnterChange: boolean
      read FEnterChange
      write FEnterChange
      default FALSE ;
    // color to which to change
    property ChangeColor: TColor
      read FChangeColor
      write FChangeColor ;

    // play a sound when button pressed?
    property PlaySound: boolean
      read FPlaySound
      write FPlaySound
      default FALSE ;
    // Sound made if Playsound = TRUE
    // use MessageBeep() constants for different sounds
    property Sound: integer
       read FSound
       write FSound
       default $FFFFFFFF ;  // speaker beep
  end ;

  TListBox = class( StdCtrls.TListBox )
  // Interposed TListBox:
  // Adds "Smart" Horizontal scrollbar
  private
  protected
    // overridden methods
    procedure CreateParams( var Params : TCreateParams ) ; override;

    // Message Handlers
    procedure LBAddString( var Msg : TMessage ) ;
      message LB_ADDSTRING ;
    procedure LBInsertString( var Msg : TMessage ) ;
      message LB_INSERTSTRING ;
    procedure LBDeleteString( var Msg : TMessage ) ;
      message LB_DELETESTRING ;
    procedure LBResetContent( var Msg : TMessage ) ;
      message LB_RESETCONTENT ;
    procedure CMFontChanged( var Msg : TMessage ) ;
      message CM_FONTCHANGED ;

    // property get/set methods
    procedure SetScrollWidth( Value : integer ) ;
    function GetScrollWidth : integer ;

    // Auxiliary Routines
    function WidthOfString( const S : string ) : integer ;
    procedure AllWidths ;
    procedure NewWidth( P : PChar ) ;

  public
  published
    // width of longest line (requires horizontal scrollbar?)
    property ScrollWidth : integer
      read GetScrollWidth
      write SetScrollWidth ;
  end ;

  FilterChars = set of char ;

  TEdit = class( StdCtrls.TEdit )
  // Interposed TEdit:
  // Adds Left and center justification
  // Adds character filtering with optional complaint beep
  private
    FFilterProc : TNotifyEvent ;
    FFilterChars : FilterChars ;
    FFilterStr   : string ;
    FErrBeep : boolean ;
    FSound : integer ;
    FAlignment : TAlignment ;
  protected
    // overridden methods
    procedure CreateParams( var Params : TCreateParams ) ; override;
    procedure Change ; override ;
    procedure KeyPress( var Key : char ) ; override ;
    procedure KeyDown( var Key : word ; Shift : TShiftState ) ; override ;

    // custom handler placeholder
    procedure FilterProc ;

    // property get/set methods
    procedure SetAlignment( Value : TAlignment ) ;
    procedure SetFilterChars( Value : string ) ;
  public
  published
    // Left, Center, or Right justify text
    // Same constants as used in TMemo and TLabel
    property Alignment: TAlignment
      read FAlignment
      write SetAlignment
      default taLeftJustify ;
    // permissable characters in edit box
    // property automatically adds #8 (BackSpace)
    property FilterChars : string
      read FFilterStr
      write SetFilterChars ;
    // beep on error?
    property ErrBeep: boolean
      read FErrBeep
      write FErrBeep
      default FALSE ;
    // Sound made if ErrBeep = TRUE
    // use MessageBeep() constants for different sounds
    property Sound: integer
      read FSound
      write FSound
      default $FFFFFFFF ;  // speaker beep
    // Custom filter function
    property OnFilter : TNotifyEvent
      read FFilterProc
      write FFilterProc ;
  end ;

  TMemo = class( StdCtrls.TMemo )
  // Interposed TMemo:
  // Adds caret position properties
  // Adds single step Undo
  private
    FOnPosChange : TNotifyEvent ;
  protected
    // overridden methods
    procedure MouseUp( Button: TMouseButton ; Shift: TShiftState ; X, Y : integer ) ; override ;
    procedure KeyUp( var Key : word ; Shift : TShiftState ) ; override ;

    // custom handler placeholder
    procedure PosChange ;

    // Property Get/set methods
    function GetRow : longint ;
    procedure SetRow( Value : longint ) ;
    function GetCol : longint ;
    procedure SetCol( Value : longint ) ;
  public
    // is last action undo-able?
    function CanUndo : boolean ;
    // Perform the Undo
    procedure Undo ;

  published
    // Line of Memo, zero based
    property Row : longint
      read GetRow
      write SetRow
      default 0 ;
    // Row of Memo, zero based
    property Col : longint
      read GetCol
      write SetCol
      default 0 ;

    // Custom handler for position change
    property OnPosChange : TNotifyEvent
      read FOnPosChange
      write FOnPosChange ;
  end ;

(*****) implementation (************************************)
//
// Interposed TPanel's Methods
//
procedure TPanel.HiThere ;
begin
  MessageBox( 0, 'Hi There!', 'Hello Message', MB_OK or MB_ICONEXCLAMATION ) ;
end;

//
// Interposed TBitBtn's Methods
//
constructor TBitBtn.Create( AOwner: TComponent ) ;
begin
  inherited Create( AOwner ) ;
  FNormalColor := Font.Color ;
  FSound := $FFFFFFFF ;  { computer speaker beep }
  FEnterChange := FALSE ;
  FPlaySound := FALSE ;
end;

procedure TBitBtn.Click ;
begin
  if FPlaySound then
    MessageBeep( FSound ) ;
  inherited Click ;
end;

procedure TBitBtn.cmMouseEnter( var Msg : TMessage ) ;
begin
  inherited ;
  if EnterChange then  // if want color change
  begin
    Font.Color := FChangeColor ;  // set to change color
  end;
end;

procedure TBitBtn.cmMouseLeave( var Msg : TMessage ) ;
begin
  if EnterChange then  // if color change enabled
  begin
    Font.Color := FNormalColor ;  // set back to normal color
  end;
  inherited ;
end;

//
// Interposed TListBox's Methods
//
procedure TListBox.CreateParams( var Params : TCreateParams ) ;
begin
  inherited CreateParams( Params ) ;
  Params.Style := Params.Style or WS_HSCROLL ;
end;

procedure TListBox.LBAddString( var Msg : TMessage ) ;
begin
  inherited ;
  NewWidth( PChar( Msg.LParam )) ;
end;

procedure TListBox.LBInsertString( var Msg : TMessage ) ;
begin
  inherited ;
  NewWidth( PChar( Msg.LParam )) ;
end;

procedure TListBox.LBDeleteString( var Msg : TMessage ) ;
begin
  inherited ;
  AllWidths;
end;

procedure TListBox.LBResetContent( var Msg : TMessage ) ;
begin
  inherited ;
  ScrollWidth := 0 ;
end;

procedure TListBox.CMFontChanged( var Msg : TMessage ) ;
begin
  inherited ;
  AllWidths;
end;

procedure TListBox.SetScrollWidth( Value : integer ) ;
begin
  Perform( LB_SETHORIZONTALEXTENT, Value, 0 ) ;
end;

function TListBox.GetScrollWidth : integer ;
begin
  Result := Perform( LB_GETHORIZONTALEXTENT, 0, 0 ) ;
end;

function TListBox.WidthOfString( const S : string ) : integer ;
begin
  Canvas.Font := Font ;
  Result := Canvas.TextWidth( S + 'X' ) ;
end;

procedure TListBox.AllWidths ;
var
  j, NewWid, Wid : integer ;
begin
  NewWid := 0 ;
  for j := 0 to Items.Count - 1 do
  begin
    Wid := WidthOfString( Items[j] ) ;
    if Wid > NewWid then
      NewWid := Wid ;
  end;
  ScrollWidth := NewWid ;
end;

procedure TListBox.NewWidth( P : PChar ) ;
var
  Wid : integer ;
begin
  Canvas.Font := Font ;
  Wid := WidthOfString( StrPas( P )) ;
  if Wid > ScrollWidth then
    ScrollWidth := Wid ;
end;

//
// Interposed TEdit's Methods
//
procedure TEdit.CreateParams ( var Params : TCreateParams ) ;
begin
  inherited CreateParams( Params ) ;
  case FAlignment of
    taLeftJustify  : // Left Justification
      Params.Style := Params.Style or ES_MULTILINE or ES_LEFT ;
    taCenter       : // Centered
      Params.Style := Params.Style or ES_MULTILINE or ES_CENTER ;
    taRightJustify : // Right Justification
      Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT ;
  end;
end;

procedure TEdit.Change ;
var
  Caret : integer ;
  SavText : string ;
begin
  FilterProc ;

  Caret := SelStart ;
  SavText := Text ;
  // Handle pasting multiple lines into control,
  // shows only first line up to first #13 (Carriage Return)
  // which is normal TEdit behavior
  if Pos( #13, SavText ) > 0 then
    SavText := Copy( SavText, 1, Pos( #13, SavText ) - 1 ) ;

  Text := SavText ;
  SelStart := Caret ;

  inherited Change ;
end;

procedure TEdit.FilterProc ;
begin
  if Assigned( FFilterProc ) then
    FFilterProc( Self ) ;
end;

procedure TEdit.KeyPress( var Key : char ) ;
begin
  if not ( FFilterStr = '' ) then
  begin
    // prevent return or enter keys from adding lines
    if ( Key = #10 ) or (Key = #13 )then
      Key := #0 ;

    // process filter chars & add BackSpace (#8)
    if not ( Key in ( FFilterChars + [#8] )) then
    begin
      if ErrBeep then
        MessageBeep( FSound ) ;
      Key := #0 ;
    end ;
  end;
  inherited KeyPress( Key ) ;
end;

procedure TEdit.KeyDown( var Key : word ; Shift : TShiftState ) ;
begin
  // prevent Ctrl-Enter or Ctrl-Tab from adding lines
  if ((Key = VK_RETURN) or (Key = VK_TAB)) and (ssCtrl in Shift) then
    Key := 0 ;
  inherited KeyDown( Key, Shift ) ;
end;

procedure TEdit.SetAlignment( Value : TAlignment ) ;
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    RecreateWnd;  // inherited from TWinControl
      // rebuilds Window based on current styles
  end;
end;

procedure TEdit.SetFilterChars( Value : string ) ;
var
  j : longint ;
begin
  if FFilterStr <> Value then
  begin
    FFilterStr := Value ;
    FFilterChars := [] ;
    for j := 1 to Length( FFilterStr ) do
    begin
      FFilterChars := FFilterChars + [FFilterStr[j]] ;
    end ;
  end;
end;

//
// Interposed TMemo's Methods
//
procedure TMemo.PosChange ;
begin
  if Assigned( FOnPosChange ) then
    FOnPosChange( Self ) ;
end;

function TMemo.GetRow : longint ;
begin
  // get line #
  Result := Perform( EM_LINEFROMCHAR, $FFFF, 0 ) ;
end;

procedure TMemo.SetRow( Value : longint ) ;
var
  VCol : longint ;
begin
  VCol := GetCol ;
  SelStart := Perform( EM_LINEINDEX, Value, 0 ) ;
  SetCol( VCol ) ;
  // no need to call PosChange, it's in SetCol
end;

function TMemo.GetCol : longint ;
var
  ro : integer ;
begin
  // get line #
  ro := Perform( EM_LINEFROMCHAR, $FFFF, 0 ) ;
  // interpolate column position from SelStart
  Result := SelStart - Perform( EM_LINEINDEX, ro, 0 ) ;
end;

procedure TMemo.SetCol( Value : longint ) ;
var
  VCol : longint;
begin
  VCol := Perform( EM_LINELENGTH, Perform( EM_LINEINDEX, GetRow, 0), 0 ) ;
  if VCol > Value then
    VCol := Value ;
  SelStart := Perform( EM_LINEINDEX, GetRow, 0 ) + VCol ;
  PosChange ;
end;

procedure TMemo.MouseUp( Button: TMouseButton ; Shift: TShiftState ; X, Y : integer ) ;
begin
  inherited MouseUp( Button, Shift, X, Y ) ;
  PosChange ;
end;

procedure TMemo.KeyUp( var Key : word ; Shift : TShiftState ) ;
begin
  inherited KeyUp( Key, Shift ) ;
  PosChange ;
end;

function TMemo.CanUndo : boolean ;
begin
  Result := Perform( EM_CANUNDO, 0, 0 ) <> 0  ;
end;

procedure TMemo.Undo ;
begin
  Perform( EM_UNDO, 0, 0 )
end;

(*****) initialization (************************************)
  (* none *)
end.